home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Graphics Plus
/
Graphics Plus.iso
/
msdos
/
viewers
/
gif_doc
/
pangif.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-07-24
|
7KB
|
272 lines
{$R-,I-}
Program panGIF;
uses CRT,Dos,GRAPH,DEGIF;
type
row = array [0..1023] of byte;
rowPtr = ^row;
var InFileName:string; BlockType:char;
I,NewBottom,NewLeft,NewRight,NewTop,
OffLeft,OffTop,Pass,XCord,YCord:integer;
InFile:File;
Buffer:array[0..32767] of byte;
BufIndx,Count:word;
Done,EOFin,SkipIt,Smash,Squeeze:Boolean;
image: array [0..1023] of rowPtr;
scale: longint;
xadj,yadj: array [0..1023] of integer;
white: byte;
scaleHeight,scaleWidth: integer;
procedure quit;
begin
textmode(lastmode);
halt;
end;
procedure Abort;
begin
close(InFile);Quit
end;
{$F+}
function GetByte: byte;
begin
if not Done
then begin
if BufIndx >= Count
then begin
Done:=EOFIn;BlockRead(InFile,Buffer,SizeOf(Buffer),Count);
EOFIn:=Count < sizeof(Buffer); BufIndx:=0
end;
GetByte:=Buffer[BufIndx]; Inc(BufIndx)
end
else GetByte:=0
end;
{$F-}
{$F+}
procedure PutByte(Pix: integer);
const YInc:array [1..5] of integer=(8,8,4,2,1);
YLin:array [1..5] of integer=(0,4,2,1,0);
var x,y:integer;
begin
x:=xadj[xCord];
y:=yadj[yCord];
if (x<320) and (y<200) then
mem[$A000:word(320*y+x)]:=Pix;
image[y]^[x]:=Pix;
Inc(XCord);
if XCord = NewRight
then begin XCord:=NewLeft;
if KeyPressed then Abort;
Inc(YCord,YInc[Pass]);
SkipIt:=Smash and ((YCord and 1)=1);
if YCord >= NewBottom then
begin
if Interlaced then Inc(Pass);
YCord:=YLin[Pass]+NewTop
end;
end
end;
{$F-}
procedure DoMapping;
var
i: integer;
regs: registers;
r,g,b: byte;
temp,max: longint;
begin
max:=0;
for i:=0 to NumberOfColors[CurMap]-1 do
begin
temp:=Sqr(Longint(redvalue[i]))+Sqr(Longint(greenvalue[i]))+Sqr(Longint(bluevalue[i]));
if temp>max then
begin max:=temp; white:=i; end;
r:=redvalue[i] div 4;
g:=greenvalue[i] div 4;
b:=bluevalue[i] div 4;
Inline($B8/$10/$10/$8B/$9E/>I/$8A/$B6/>R/$8A/$AE/>G/$8A/$8E/>B/$CD/$10);
end;
end;
procedure AdjustImage;
var i: integer;
begin
NewLeft := ImageLeft + OffLeft;
NewTop := ImageTop + OffTop;
NewRight := ImageWidth + NewLeft;
NewBottom:= ImageHeight + NewTop;
XCord:=NewLeft; YCord:=NewTop;
if Interlaced then Pass:=1 else Pass:=5;
scale:=1024;
while MemAvail*15 div 16<(scale*imageWidth div 1024)*(scale*imageHeight div 1024) do
Dec(scale);
for i:=0 to ImageWidth-1 do
xadj[i]:=scale*i div 1024;
for i:=0 to ImageHeight-1 do
yadj[i]:=scale*i div 1024;
scaleHeight:=scale*ImageHeight div 1024;
scaleWidth:=scale*ImageWidth div 1024;
for i:=0 to scaleHeight-1 do
GetMem(image[i],scaleWidth);
end;
procedure DisplayScrDes;
var I:integer;
AnsCh:char;
begin
Writeln(ScreenWidth,'x',ScreenHeight,' ',NumberOfColors[Global],' colors');
OffLeft:=0; OffTop:=0;
Smash:=false; Squeeze:=false;
end;
procedure GraphColorMode;
begin { procedure GraphColorMode }
inline($B8/$13/$00/$CD/$10);
DoMapping;
end; { procedure GraphColorMode }
procedure pan;
var
done: boolean;
ch: char;
x,y: integer;
procedure slideRight;
var h,v,b: word; x0: integer;
begin { procedure slideRight }
if x=0 then exit;
x0:=x;
Dec(x,10); if x<0 then x:=0;
for v:=0 to 199 do
begin
b:=word(320*v);
Move(mem[$A000:b],mem[$A000:b+x0-x],320+x-x0);
Move(image[y+v]^[x],mem[$A000:b],x0-x);
end;
end; { procedure slideRight }
procedure slideLeft;
var h,v,b: word; x0: integer;
begin { procedure slideLeft }
if x=scaleWidth-320 then exit;
x0:=x;
Inc(x,10); if x+320>scaleWidth then x:=scaleWidth-320;
for v:=0 to 199 do
begin
b:=word(320*v);
Move(mem[$A000:b+x-x0],mem[$A000:b],320+x0-x);
Move(image[y+v]^[320+x0],mem[$A000:b+320+x0-x],x-x0);
end;
end; { procedure slideLeft }
procedure slideDown;
var h,v,b: word; y0: integer;
begin { procedure slideDown }
if y=0 then exit;
y0:=y;
Dec(y,10); if y<0 then y:=0;
Move(mem[$a000:0],mem[$a000:320*(y0-y)],word(320*(200+y-y0)));
for v:=0 to y0-y-1 do
begin
b:=word(320*v);
Move(image[y+v]^[x],mem[$A000:b],320);
end;
end; { procedure slideDown }
procedure slideUp;
var h,v,b: word; y0: integer;
begin { procedure slideUp }
if y=scaleHeight-200 then exit;
y0:=y;
Inc(y,10); if y+200>scaleHeight then y:=scaleHeight-200;
Move(mem[$A000:320*(y-y0)],mem[$A000:0],word(320*(200+y0-y)));
for v:=200+y0-y to 199 do
begin
b:=word(320*v);
Move(image[y+v]^[x],mem[$A000:b],320);
end;
end; { procedure slideUp }
begin { procedure pan }
x:=0; y:=0; done:=false;
repeat
ch:=readkey;
if ch=#0 then
case readkey of
#75: if scaleWidth>320 then slideRight;
#77: if scaleWidth>320 then slideLeft;
#72: if scaleHeight>200 then slideDown;
#80: if scaleHeight>200 then slideUp;
end
else
case ch of
#27: done:=True;
end;
until done;
end; { procedure pan }
begin
AddrGetByte:=@GetByte;
AddrPutByte:=@PutByte;
AssignCrt(output);Rewrite(OUTPUT);
if paramcount=0
then begin
write('Enter GIF file name: '); readln(infilename);
end
else InFileName:=paramstr(1);
if length(InFileName)>0 then
begin
if pos('.',infilename)=0 then infilename:=infilename+'.gif';
assign(InFile,InFileName);
{$I-}
reset(InFile,1);
if ioresult<>0
then begin writeln('GIF datafile could not be found.'); halt; end;
SkipIt:=false;
EOFin:=false;
Done:=false;
BufIndx:=999;Count:=0;
CurMap:=Global;
GetGIFSig;
if GIFSig<>'GIF87a' then
begin
BufIndx:=128;
GetGIFSig;
if GIFSig<>'GIF87a' then
begin
writeln('Invalid GIF signature');
Halt;
end;
end;
GetScrDes;
DisplayScrDes;
if MapExists[Global] then GetColorMap;
writeln('Press <Enter> to display and wait for beep');
writeln('before scrolling image with arrow keys');
readln;
GraphColorMode;
while not Done Do
begin
BlockType:=chr(GetByte);
case BlockType of
',':begin
GetImageDescription;
AdjustImage;
if MapExists[Local]
then begin CurMap:=Local; GetColorMap; DoMapping end
else CurMap:=Global;
if ExpandGIF <>0 then Halt
end;
'!':SkipExtendBlock;
end;
end;
end;
Sound(1000);Delay(100);NoSound;
pan;
textmode(lastmode);
end.